home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / hyperbole / hvm.el < prev    next >
Encoding:
Text File  |  1995-07-08  |  16.1 KB  |  468 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         hvm.el
  4. ;; SUMMARY:      Support Hyperbole buttons in mail reader: Vm.
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     hypermedia, mail
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Brown U.
  10. ;;
  11. ;; ORIG-DATE:    10-Oct-91 at 01:51:12
  12. ;; LAST-MOD:     23-Jun-95 at 14:55:05 by Bob Weiner
  13. ;;
  14. ;; This file is part of Hyperbole.
  15. ;; Available for use and distribution under the same terms as GNU Emacs.
  16. ;;
  17. ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
  18. ;; Developed with support from Motorola Inc.
  19. ;;
  20. ;; DESCRIPTION:  
  21. ;;
  22. ;;   Automatically configured for use in "hyperbole.el".
  23. ;;   If hsite loading fails prior to initializing Hyperbole Vm support,
  24. ;;
  25. ;;       {M-x Vm-init RTN}
  26. ;;
  27. ;;   will do it.
  28. ;;
  29. ;; DESCRIP-END.
  30.  
  31. ;;; ************************************************************************
  32. ;;; Other required Elisp libraries
  33. ;;; ************************************************************************
  34.  
  35. (require 'hmail)
  36. (load "hsmail")
  37. (require 'vm)
  38. (or (and (fboundp 'vm-edit-message) (fboundp 'vm-edit-message-end))
  39.     (load "vm-edit"))
  40. (vm-session-initialization)
  41.  
  42. ;;; ************************************************************************
  43. ;;; Public variables
  44. ;;; ************************************************************************
  45.  
  46. ;;; Current versions of VM define this next variable in "vm-vars.el".  We
  47. ;;; define it here for earlier VM versions.
  48. (defvar vm-edit-message-mode nil
  49.   "*Major mode to use when editing messages in VM.")
  50.  
  51. ;;; "hmail.el" procedures will branch improperly if a regular mode, like VM's
  52. ;;; default 'text-mode', is used for editing.
  53. (setq vm-edit-message-mode 'vm-edit-mode)
  54.  
  55. (defun vm-edit-mode ()
  56.   "Major mode for editing vm mail messages.
  57.   Special commands:\\{vm-edit-message-map}
  58. Turning on vm-edit-mode calls the value of the variable vm-edit-message-hook,
  59. if that value is non-nil."
  60.   (interactive)
  61.   (kill-all-local-variables)
  62.   (use-local-map vm-edit-message-map)
  63.   (setq mode-name "VM Edit")
  64.   (setq major-mode 'vm-edit-mode)
  65.   (setq local-abbrev-table text-mode-abbrev-table)
  66.   (set-syntax-table text-mode-syntax-table)
  67.   (run-hooks 'vm-edit-message-hook))
  68.  
  69. ;;; ************************************************************************
  70. ;;; Public functions
  71. ;;; ************************************************************************
  72.  
  73. (defun Vm-init ()
  74.   "Initializes Hyperbole support for Vm mail reading."
  75.   (interactive)
  76.   (setq hmail:composer  'mail-mode
  77.     hmail:lister    'vm-summary-mode
  78.     hmail:modifier  'vm-edit-mode
  79.     hmail:reader    'vm-mode)
  80.   ;;
  81.   ;; Setup public abstract interface to Hyperbole defined mail
  82.   ;; reader-specific functions used in "hmail.el".
  83.   ;;
  84.   (rmail:init)
  85.   ;;
  86.   ;; Setup private abstract interface to mail reader-specific functions
  87.   ;; used in "hmail.el".
  88.   ;;
  89.   (fset 'rmail:get-new       'vm-get-new-mail)
  90.   (fset 'rmail:msg-forward   'vm-forward-message)
  91.   (fset 'rmail:summ-msg-to   'vm-follow-summary-cursor)
  92.   (fset 'rmail:summ-new      'vm-summarize)
  93.   (if (interactive-p)
  94.       (message "Hyperbole VM mail reader support initialized."))
  95.   )
  96.  
  97. (defun Vm-msg-hdrs-full (toggled)
  98.   "If TOGGLED is non-nil, toggle full/hidden headers, else show full headers."
  99.   (save-excursion
  100.     (if (or toggled
  101.         (let ((exposed (= (point-min)
  102.                   (vm-start-of (car vm-message-pointer)))))
  103.           (not exposed)))
  104.     (progn (vm-expose-hidden-headers)
  105.            (setq toggled t)))
  106.     toggled))
  107.  
  108. (defun Vm-msg-narrow ()
  109.   "Narrows mail reader buffer to current message.
  110. This includes Hyperbole button data."
  111.   (save-excursion
  112.     (vm-select-folder-buffer)
  113.     (narrow-to-region (point-min) (Vm-msg-end))))
  114.  
  115. (defun Vm-msg-next ()           (vm-next-message 1))
  116.  
  117. (defun Vm-msg-num ()
  118.   "Returns number of vm mail message that point is within, in physical message order."
  119.   (interactive)
  120.   (let ((count 1)
  121.     (case-fold-search))
  122.     (save-excursion
  123.       (save-restriction
  124.     (widen)
  125.     (while (re-search-backward Vm-msg-start-regexp nil t)
  126.       (setq count (1+ count)))))
  127.     count))
  128.  
  129. (defun Vm-msg-prev ()           (vm-previous-message 1))
  130.  
  131. (defun Vm-msg-to-p (mail-msg-id mail-file)
  132.   "Sets current buffer to start of msg with MAIL-MSG-ID in MAIL-FILE.
  133. Returns t if successful, else nil or signals error."
  134.   (if (not (file-readable-p mail-file))
  135.       nil
  136.     (vm-visit-folder mail-file)
  137.     (widen)
  138.     (goto-char 1)
  139.       (if (let ((case-fold-search))
  140.         (re-search-forward (concat rmail:msg-hdr-prefix
  141.                        (regexp-quote mail-msg-id)) nil t))
  142.       ;; Found matching msg
  143.       (progn
  144.         (setq buffer-read-only t)
  145.         (vm-goto-message-at-point)
  146.         t))))
  147.  
  148. (defun Vm-msg-widen ()
  149.   "Widens buffer to full current message including Hyperbole button data."
  150.   (save-excursion
  151.     (vm-select-folder-buffer)
  152.     (narrow-to-region (point-min) (Vm-msg-end))))
  153.  
  154. (defun Vm-to ()
  155.   "Sets current buffer to a mail reader buffer."
  156.   (and (eq major-mode 'vm-summary-mode) (set-buffer vm-mail-buffer)))
  157.  
  158. (defun Vm-Summ-delete ()
  159.   (vm-follow-summary-cursor)
  160.   (vm-delete-message 1))
  161.  
  162. (fset 'Vm-Summ-expunge          'vm-expunge-folder)
  163.  
  164. (fset 'Vm-Summ-goto             'vm-follow-summary-cursor)
  165.  
  166. (defun Vm-Summ-to ()
  167.   "Sets current buffer to a mail listing buffer."
  168.   (and (eq major-mode 'vm-mode) (set-buffer vm-summary-buffer)))
  169.  
  170. (defun Vm-Summ-undelete-all ()
  171.   (message
  172.    "(Vm-Summ-undelete-all: Vm doesn't have an undelete all msgs function."))
  173.  
  174. ;;; ************************************************************************
  175. ;;; Private functions
  176. ;;; ************************************************************************
  177.  
  178. (defun Vm-msg-end ()
  179.   "Returns end point for current Vm message, including Hyperbole button data.
  180. Has side-effect of widening buffer."
  181.   (save-excursion
  182.     (goto-char (point-min))
  183.     (widen)
  184.     (if (let ((case-fold-search))
  185.       (re-search-forward Vm-msg-start-regexp nil t))
  186.     (match-beginning 0)
  187.       (point-max))))
  188.  
  189. ;;; Overlay version of this function from "vm-page.el" to hide any
  190. ;;; Hyperbole button data whenever a message is displayed in its entirety.
  191. (defun vm-show-current-message ()
  192.   (save-excursion
  193.     (save-excursion
  194.       (goto-char (point-min))
  195.       (hmail:msg-narrow (point-min) (Vm-msg-end)))
  196.     (and vm-honor-page-delimiters
  197.      (save-excursion
  198.        (if (search-forward page-delimiter nil t)
  199.            (progn
  200.          (goto-char (match-beginning 0))
  201.          (not (looking-at (regexp-quote hmail:hbdata-sep))))))
  202.      (progn
  203.        (if (looking-at page-delimiter)
  204.            (forward-page 1))
  205.        (vm-narrow-to-page))))
  206.   ;; don't mark the message as read if the user can't see it!
  207.   (if (vm-get-buffer-window (current-buffer))
  208.       (progn
  209.     (setq vm-system-state 'showing)
  210.     (cond ((vm-new-flag (car vm-message-pointer))
  211.            (vm-set-new-flag (car vm-message-pointer) nil)))
  212.     (cond ((vm-unread-flag (car vm-message-pointer))
  213.            (vm-set-unread-flag (car vm-message-pointer) nil)))
  214.     (vm-update-summary-and-mode-line)
  215.     (vm-howl-if-eom))
  216.     (if (fboundp 'hproperty:but-create) (hproperty:but-create))
  217.     (vm-update-summary-and-mode-line)))
  218.  
  219. ;;; Overlay version of this function from "vm-page.el" to treat end of
  220. ;;; text (excluding Hyperbole button data) as end of message.
  221. (defun vm-scroll-forward-internal (arg)
  222.   (let ((direction (prefix-numeric-value arg))
  223.     (w (selected-window)))
  224.     (condition-case error-data
  225.     (progn (scroll-up arg) nil)
  226.       (error
  227.        (if (or (and (< direction 0)
  228.             (> (point-min) (vm-text-of (car vm-message-pointer))))
  229.            (and (>= direction 0)
  230.             (/= (point-max)
  231.             (save-restriction
  232.               (hmail:hbdata-start
  233.                (point-min)
  234.                (vm-text-end-of
  235.                 (car vm-message-pointer)))))))
  236.        (progn
  237.          (vm-widen-page)
  238.          (if (>= direction 0)
  239.          (progn
  240.            (forward-page 1)
  241.            (set-window-start w (point))
  242.            nil )
  243.            (if (or (bolp)
  244.                (not (save-excursion
  245.                   (beginning-of-line)
  246.                   (looking-at page-delimiter))))
  247.            (forward-page -1))
  248.            (beginning-of-line)
  249.            (set-window-start w (point))
  250.            'tryagain))
  251.      (if (eq (car error-data) 'end-of-buffer)
  252.          (if vm-auto-next-message
  253.          'next-message
  254.            (set-window-point w (point))
  255.            'end-of-message)))))))
  256.  
  257. ;;; Overlay version of this function from "vm-page.el" (called by
  258. ;;; vm-scroll-* functions).  Make it keep Hyperbole button data hidden.
  259. (defun vm-widen-page ()
  260.   (if (or (> (point-min) (vm-text-of (car vm-message-pointer)))
  261.       (/= (point-max) (vm-text-end-of (car vm-message-pointer))))
  262.       (hmail:msg-narrow (vm-vheaders-of (car vm-message-pointer))
  263.             (if (or (vm-new-flag (car vm-message-pointer))
  264.                 (vm-unread-flag (car vm-message-pointer)))
  265.                 (vm-text-of (car vm-message-pointer))
  266.               (vm-text-end-of (car vm-message-pointer))))))
  267.  
  268. ;;; Overlay version of this function from "vm-edit.el" to hide
  269. ;;; Hyperbole button data when insert edited message from temporary buffer.
  270. (hypb:function-overload 'vm-edit-message nil '(hmail:msg-narrow))
  271.  
  272. ;;; Overlay version of this function from "vm-edit.el" to hide
  273. ;;; Hyperbole button data when insert edited message from temporary buffer.
  274. (defun vm-edit-message-end ()
  275.   "End the edit of a message and copy the result to its folder."
  276.   (interactive)
  277.   (if (null vm-message-pointer)
  278.       (error "This is not a VM message edit buffer."))
  279.   (if (null (buffer-name (vm-buffer-of (car vm-message-pointer))))
  280.       (error "The folder buffer for this message has been killed."))
  281.   ;; make sure the message ends with a newline
  282.   (goto-char (point-max))
  283.   (and (/= (preceding-char) ?\n) (insert ?\n))
  284.   ;; munge message separators found in the edited message to
  285.   ;; prevent message from being split into several messages.
  286.   (vm-munge-message-separators (vm-message-type-of (car vm-message-pointer))
  287.                    (point-min) (point-max))
  288.   ;; for From_-with-Content-Length recompute the Content-Length header
  289.   (if (eq (vm-message-type-of (car vm-message-pointer))
  290.       'From_-with-Content-Length)
  291.       (let ((buffer-read-only nil)
  292.         length)
  293.     (goto-char (point-min))
  294.     ;; first delete all copies of Content-Length
  295.     (while (and (re-search-forward vm-content-length-search-regexp nil t)
  296.             (null (match-beginning 1))
  297.             (progn (goto-char (match-beginning 0))
  298.                (vm-match-header vm-content-length-header)))
  299.       (delete-region (vm-matched-header-start) (vm-matched-header-end)))
  300.     ;; now compute the message body length
  301.     (goto-char (point-min))
  302.     (search-forward "\n\n" nil 0)
  303.     (setq length (- (point-max) (point)))
  304.     ;; insert the header
  305.     (goto-char (point-min))
  306.     (insert vm-content-length-header " " (int-to-string length) "\n")))
  307.   (let ((edit-buf (current-buffer))
  308.     (mp vm-message-pointer))
  309.     (if (buffer-modified-p)
  310.     (progn
  311.       (widen)
  312.       (save-excursion
  313.         (set-buffer (vm-buffer-of (vm-real-message-of (car mp))))
  314.         (if (not (memq (vm-real-message-of (car mp)) vm-message-list))
  315.         (error "The original copy of this message has been expunged."))
  316.         (vm-save-restriction
  317.          (widen)
  318.          (goto-char (vm-headers-of (vm-real-message-of (car mp))))
  319.          (let ((vm-message-pointer mp)
  320.            (buffer-read-only nil))
  321.            (insert-buffer-substring edit-buf)
  322.            (delete-region
  323.         (point) (vm-text-end-of (vm-real-message-of (car mp))))
  324.            (vm-discard-cached-data)
  325.            (hmail:msg-narrow))
  326.          (vm-set-edited-flag-of (car mp) t)
  327.          (vm-mark-for-summary-update (car mp))
  328.          (if (eq vm-flush-interval t)
  329.          (vm-stuff-virtual-attributes (car mp))
  330.            (vm-set-modflag-of (car mp) t))
  331.          (vm-set-buffer-modified-p t)
  332.          (vm-clear-modification-flag-undos)
  333.          (vm-set-edit-buffer-of (car mp) nil))
  334.         (set-buffer (vm-buffer-of (car mp)))
  335.         (if (eq (vm-real-message-of (car mp))
  336.             (vm-real-message-of (car vm-message-pointer)))
  337.         (vm-preview-current-message)
  338.           (vm-update-summary-and-mode-line))))
  339.       (message "No change."))
  340.     (vm-display edit-buf nil '(vm-edit-message-end)
  341.         '(vm-edit-message-end reading-message startup))
  342.     (set-buffer-modified-p nil)
  343.     (kill-buffer edit-buf)))
  344.  
  345. ;;; Define this function if VM version in use doesn't have it.
  346. (or (fboundp 'vm-goto-message-at-point)
  347. (defun vm-goto-message-at-point ()
  348.   "In a VM folder buffer, select the message that contains point."
  349.   (cond ((fboundp 'vm-update-search-position)
  350.      (vm-update-search-position t)
  351.      ;; vm-show-current-message only adjusts (point-max),
  352.      ;; it doesn't change (point-min).
  353.      (narrow-to-region
  354.       (vm-vheaders-of (car vm-message-pointer))
  355.       (point-max))
  356.      (vm-show-current-message)
  357.      (setq vm-system-state 'reading))
  358.     ((fboundp 'vm-isearch-update)
  359.      (vm-isearch-update)
  360.      (narrow-to-region
  361.       (vm-vheaders-of (car vm-message-pointer))
  362.       (point-max))
  363.      (vm-show-current-message)
  364.      (setq vm-system-state 'reading))
  365.     (t (error "vm search code is missing, can't continue"))))
  366. )
  367.  
  368. ;;; Hide any Hyperbole button data when reply to or forward a message.
  369. ;;; See "vm-reply.el".
  370. (var:append 'vm-mail-mode-hook '(hmail:msg-narrow))
  371.  
  372. ;;; Overlay this function from "vm-folder.el" called whenever new mail is
  373. ;;; incorporated so that it will highlight Hyperbole buttons when possible.
  374. ;;  Returns non-nil if there were any new messages.
  375. (defun vm-assimilate-new-messages (&optional dont-read-attributes gobble-order)
  376.   (let ((tail-cons (vm-last vm-message-list))
  377.     b-list new-messages)
  378.     (save-excursion
  379.       (vm-save-restriction
  380.        (widen)
  381.        (if (fboundp 'hproperty:but-create)
  382.        (hproperty:but-create))
  383.        (vm-build-message-list)
  384.        (if (or (null tail-cons) (cdr tail-cons))
  385.        (progn
  386.          (setq vm-ml-sort-keys nil)
  387.          (if dont-read-attributes
  388.          (vm-set-default-attributes (cdr tail-cons))
  389.            (vm-read-attributes (cdr tail-cons)))
  390.          ;; Yuck.  This has to be done here instead of in the
  391.          ;; vm function because this needs to be done before
  392.          ;; any initial thread sort (so that if the thread
  393.          ;; sort matches the saved order the folder won't be
  394.          ;; modified) but after the message list is created.
  395.          ;; Since thread sorting is done here this has to be
  396.          ;; done here too.
  397.          (if gobble-order
  398.          (vm-gobble-message-order))
  399.          (if vm-thread-obarray
  400.          (vm-build-threads (cdr tail-cons))))))
  401.       (setq new-messages (if tail-cons (cdr tail-cons) vm-message-list))
  402.       (vm-set-numbering-redo-start-point new-messages)
  403.       (vm-set-summary-redo-start-point new-messages))
  404.     (if vm-summary-show-threads
  405.     (progn
  406.       ;; get numbering and summary of new messages done now
  407.       ;; so that the sort code only has to worry about the
  408.       ;; changes it needs to make.
  409.       (vm-update-summary-and-mode-line)
  410.       ;; copy the new-messages list because sorting might
  411.       ;; scramble it.  vm-assimilate-new-messages returns
  412.       ;; this value.
  413.       (setq new-messages (copy-sequence new-messages))
  414.       (vm-sort-messages "thread")))
  415.     (if (and new-messages vm-virtual-buffers)
  416.     (save-excursion
  417.       (setq b-list vm-virtual-buffers)
  418.       (while b-list
  419.         ;; buffer might be dead
  420.         (if (buffer-name (car b-list))
  421.         (let (tail-cons)
  422.           (set-buffer (car b-list))
  423.           (setq tail-cons (vm-last vm-message-list))
  424.           (vm-build-virtual-message-list new-messages)
  425.           (if (or (null tail-cons) (cdr tail-cons))
  426.               (progn
  427.             (setq vm-ml-sort-keys nil)
  428.             (if vm-thread-obarray
  429.                 (vm-build-threads (cdr tail-cons)))
  430.             (vm-set-summary-redo-start-point
  431.              (or (cdr tail-cons) vm-message-list))
  432.             (vm-set-numbering-redo-start-point
  433.              (or (cdr tail-cons) vm-message-list))
  434.             (if (null vm-message-pointer)
  435.                 (progn (setq vm-message-pointer vm-message-list
  436.                      vm-need-summary-pointer-update t)
  437.                    (if vm-message-pointer
  438.                        (vm-preview-current-message))))
  439.             (if vm-summary-show-threads
  440.                 (progn
  441.                   (vm-update-summary-and-mode-line)
  442.                   (vm-sort-messages "thread")))))))
  443.         (setq b-list (cdr b-list)))))
  444.     new-messages ))
  445.  
  446. ;;; Overlay version of 'vm-force-mode-line-update' from "vm-folder.el"
  447. ;;; to highlight Hyperbole buttons in summary buffers.
  448. (defun vm-force-mode-line-update ()
  449.   "Force a mode line update in all frames."
  450.   (if vm-summary-buffer
  451.       (save-excursion
  452.     (set-buffer vm-summary-buffer)
  453.     (if (fboundp 'hproperty:but-create) (hproperty:but-create))))
  454.   (if (fboundp 'force-mode-line-update)
  455.       (force-mode-line-update t)
  456.     (save-excursion
  457.       (set-buffer (other-buffer))
  458.       (set-buffer-modified-p (buffer-modified-p)))))
  459.  
  460. ;;; ************************************************************************
  461. ;;; Private variables
  462. ;;; ************************************************************************
  463.  
  464. (defvar Vm-msg-start-regexp "\n\nFrom \\|\n\001\001\001\001"
  465.   "Regular expression that begins a Vm mail message.")
  466.  
  467. (provide 'hvm)
  468.